perm filename BMSTF.OLD[XX,LCS] blob sn#207668 filedate 1976-03-24 generic text, type T, neo UTF8
00100	C**** BMSTF, BMS, METER, RNOTE, MAKNUM, IABS, DRWNT, RHORZ, RDRAW
00200	C  ********** WHOLE & HALF RESTS, BEAMS ******
00300		SUBROUTINE BMSTF
00400		IMPLICIT INTEGER(A-Q,S-Z)
00500		REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1
00600		COMMON/STF/RSTFAC(-3/4),RSTJ2/MIN/MINI,RMINI
00700		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
00800		COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
00900		COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
01000		1 RJA,YY,DISX,HGT,RZ,INP(53)
01100		EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
01200		1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01300		1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1))
01400		1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8)),(RX3,RJQ(20))
01500		DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
01600	C  RDBR IS SPACER FOR DBL BAR.
01700	C  RTF COMPENSATES FOR BAD PLANNING.
01710		IF(JA.NE.8)GO TO 100
01720		CALL STAFF
01730		RETURN
01800	100	RST7=RSTJ2*7.
01900		RST18=RSTJ2*18.
02000	C  TO COMPENSATE FOR NOTE #3 COMING AT POS=0
02100	
02200		R3Q=R3
02400	C  NEXT IS FOR BEAMS
02500		RMINI=RSTJ2
02600		RX=2.7*RSTJ2*5.96
02700	C******************************
02800		R6=RHORZ(R6)
02900		IF(R8.NE.0)GO TO 204
03000		IF(R10.GE.10)GO TO 204
03100		IF(J7)GO TO 204
03200		IF(R9.NE.0)GO TO 1
03300	C  R8=0 AND R9=NUM  -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLETS, ETC.)
03400	204	IF(R9.NE.0)R9=RHORZ(R9)
03500		IF(J7)GO TO 201
03600	200	IF(J10.LT.10)GO TO 91
03700	C NEXT FOR INNER, PARTIAL BEAMS
03800		R8=RHORZ(R8)
03900		R10=AMOD(R10,10.)
04000		GO TO(2,3,4),J10/10
04100	2	RH=R9+RX
04200		GO TO 1
04300	3	R8=R9-RX
04400	C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
04500	4	RH=R8
04600	C  LEFT INNER POS.
04700		GO TO 1
04800	201	J7=-J7
04900	C P8=WIDTH OF TREM. P9=0(SANS OTHER BEAMS) OR =POS.3, P10=DISP.
05000		CALL NOZERO(R10)
05100	C  ALWAYS AT LEAST 1 IN DISPLACEMENT
05200		J10=30
05300	C TO ACTIVATE PARTIAL BEAM SECTION
05400		IF(J9.NE.0)GO TO 202
05500	C  NEXT FOR TREM. WITHOUT OTHER BEAMS.
05600		RH=-1
05700		IF(J7.GE.20)RH=-RH
05800	CC203	R4=R4+R10*RH
05900	CC	CALL CENTX
06000		R5=R4+RH
06100		R9=R3
06200		R6=R3+22.*RMINI
06300	202	IF(R8.EQ.0)R8=4. 
06400		RX=R8*RMINI*2.98
06500		RH=R9+RX
06600		R9=R9-RX
06700		GO TO 1
06800	
06900	91	IF(J8.EQ.0)GO TO 1
07000		IF(J8.GT.0)GO TO 92
07100	C FOR J8=-(10+DN) OR -(20+DN)
07200		R9=R3+RX
07300		IF(J8.LE.-20)R9=R6-RX
07400	192	J8=-J8
07500	92	IF(J10.EQ.0)J10=MOD(J8,10)
07600	CC??? 4/75	J8=J8-J10
07700		IF(J10.EQ.0)J10=1
07800		R10=J10
07900	C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
08000	1	IF(IABS(J4).LT.100)GO TO 97
08100		RMINI=.6*RSTJ2
08200		R5=AMOD(R5,100.0)
08300	C   SPACE BETWEEN BEAMS
08400	97	RJ=RMINI*11.
08500		RW=RMINI*RHGT
08600	C  DIST. UP OR DOWN FROM NOTE HEAD.
08700		RJA=R10*RJ
08800	C  DISPLACEMENT
08900		RD=R9
09000	C  POSITION 3
09100		RJX=CENTR-RW+RJA
09200	C  FINAL HEIGHT OF LEFT SIDE
09300	C  NEG R7=TREMOLO
09400		RX=MOD(J7,10)
09500		JJ2=J7-20
09600		RA=R6
09700	C  HORIZANTAL DIST.
09800		RJY=R5*RST7+POS-RST18-RW+RJA
09900	C   VERTICAL POS OF RIGHT SIDE.
10000		RW=R14*RMINI
10100		RY=1.
10200		IF(J7.GE.20)GO TO 98 
10300	C JUMP IF STEMS ARE DOWN
10400		RY=-RY
10500	C  FOR  THICKENING INCR.
10600		JJ2=J7-10
10700		RJ=-RJ
10800		RJA=RMINI*R2HGT-2.*RJA
10900		RJX=RJX+RJA
11000		RJY=RJY+RJA
11100		R3Q=R3Q+RW
11200	C  POSITION 1
11300		RA=RA+RW
11400	C  POSITION 2
11500		RD=RD+RW
11600	C******************************
11700		RH=RH+RW
11800	98	RSTJ2=RSTJ2*RBM
11900	C  RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
12000	93	IF(JJ2.GT.RX)GO TO 94
12100		IF(J10.GE.10)GO TO 7
12200	C**********************
12300		IF(J8.EQ.0)GO TO 94
12400		R3=RW
12500		IF(J9.EQ.0)GO TO 292
12600	 	IF(J8.GE.20)GO TO 193
12700	293	RX=R3Q-RD
12800		GO TO 194
12900	7	RHX=RH-R3Q
13000		R3=RD-R3Q
13100		GO TO 292
13200	193	RX=RD-RA
13300	194	R3=ABS(RX)
13400	292	DISX=ABS(R3Q-RA)
13500		HGT=RJX-RJY
13600		IF(J10.GE.10)HGT1=HGT*RHX/DISX
13700	C**********************
13800		R3=R3/DISX
13900	195	HGT=HGT*R3
14000	196	L=J8/10
14100		J8=0
14200		IF(J10.GE.10)GO TO 8
14300	C***************
14400		IF(L.EQ.1)GO TO 95
14500	C   BEAM LFT=1,  RT=2   (PARAM 8=10 OR 20)
14600		R3Q=RD
14700		RJX=RJY+HGT
14800		GO TO 94
14900	C**************
15000	8	R3Q=RH
15100		RA=RD
15200		RJY=RJX-HGT
15300		RJX=RJX-HGT1
15400		GO TO 94
15500	95	RA=RD
15600		RJY=RJX-HGT
15700	94	L=7.*RMINI
15800	930	RC=0
15900	C  MINI LINES HAVE .2 SMALLER BEAMS.  MAYBE CHANGE THIS??
16000		CALL LINES(R3Q,RJX,3)
16100		DO 941 K=1,L
16200		CALL BMS
16300		IF(PLT.GE.0)GO TO 940
16400		RC=RC+RY
16500	C FOR THICKENING.
16600		CALL BMS
16700		CALL EXCH(RA,R3Q)
16800	941	CALL EXCH(RJY,RJX)
16900		CALL BMS
17000	C  DRAWS 5 LINES FOR BEAMS.
17100	940	JJ2=JJ2-1
17200		IF(JJ2.LE.0)GO TO 942
17300	C  IF P7=10 OR 20 ONE BEAM WILL APPEAR.
17400		RJY=RJY+RJ
17500		RJX=RJX+RJ
17600		GO TO 930
17700	
17800	942	IF(R8.NE.0)RETURN
17900		IF(R9.EQ.0)RETURN
18000		IF(R10.GE.30)RETURN
18100	C FOR NUMBERS OUTSIDE BEAMS
18200		RSTJ2=RMINI
18300		RD=-10.
18400		IF(R7.LT.20)RD=8.3
18500	943	J3=R3Q+(RA-R3Q)/2.
18600		R6=1.
18700	CC *** DONE IN CENTX ***	R4=AMOD(R4,100.)
18800		R4=R4+(R5-R4)/2.+RD
18900		R7=1
19000	C ITALICS
19100		CALL MAKNUM(R9)
19300		END
23700	
23800	CC	SUBROUTINE BMS
23900	CC	COMMON/STF/RSTFAC(-3/4),RSTJ2/BM/RA,RC,RJY
24000	CC	CALL LINES(RA,RJY+RC*RSTJ2,2)
24100	CC	END
24200	
24300		SUBROUTINE METER
24400	      COMMON R2,JA,CENTR,J2,RJQ(20),J3,JQ(19)/STF/RSTFAC(-3/4),RSTJ2
24500		COMMON/POSI/STFF(-3/4),JJ2,POS
24600		EQUIVALENCE (R4,RJQ(2)),(R7,RJQ(5)),(R6,RJQ(4)),(R5,RJQ(3))
24700		1,(R8,RJQ(6)),(RX3,RJQ(20)),(J10,JQ(7)),(J7,JQ(5)),(R9,RJQ(7))
24800	
24900	C  PARAMS  18 / STF / POS / VERT HGT./ TOP NUM/ BOT NUM/ SIZE FAC.
25000	
25100		CALL NOZERO(R7)
25200		JZ=J3
25300		RY=R4+8.*R7
25400	C  HEIGHT
25500		RW=R6
25600	C  BOTTOM NUM
25700	C  P5=TOP NUM
25800		R6=R7
25900		RR6=R6
26000	C  SIZE
26100	C  FOR BDR40  -- OR =1
26200		M=0
26300		R4=RY
26400	2	R7=0
26500	C  R7=0 FOR BDR FONT??
26600	CC	IF(R5.NE.99)GO TO 1
26700		IF(R5.LT.90)GO TO 3
26800	C  99 AS METER = 'C'  98=ALLA BREVE (CUT TIME)
26900		M=-1
27000		IF(R5.NE.98)GO TO 4
27100	C NEXT FOR LINE THROUGH C.
27200		RZ=R6
27300		RY=R4
27400		RA=POS
27500		R6=RX3
27600	C  TO LINE UP WITH R3
27700		J10=2
27800	C  FOR THICK LINE
27810	CC	R5=9.8+R4
27900	CC	R4=R4+4.2
28000		R4=R4-3.8
28050		R5=R4+5.6
28100		J7=0
28200		R8=0
28300		CALL ITMSUB
28400		POS=RA
28500		R4=RY
28600		R6=RZ
28700	C GET BACK THE RIGHT PARAMS.
28800	
28900	4	R5=9999.
29000		GO TO 3
29100	C  TO CENTER 12S AND 16S
29200	3	CALL MAKNUM(R5)
29300		IF(M)RETURN
29400	C  STICK AROUND FOR BOTTOM NUM
29500		M=-1
29600		R4=RY-4.*RR6
29700		R6=RR6
29800		R5=RW
29900	C  GET BOTTOM NUM
30000		J3=JZ
30100		R8=0
30200		GO TO 2
30300		END
30400	
30500	CF	SUBROUTINE RNOTE(X)
30600	CF	COMMON /PTR/PWDS(250),ITEM,L,I,IX/XRN/RN(4000)
30700	CF	X=RN(IFIX(PWDS(IFIX(AMOD(X,1000.))))+2)
30800	CF	END
30900	
31000		SUBROUTINE MAKNUM(RNUM)
31100		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/STF/RSTFAC(-3/4),RSTJ2
31200		EQUIVALENCE (J3,JQ(1)),(R4,RJQ(2)),(R8,RJQ(6)),(R7,RJQ(5))
31300	     1,(R6,RJQ(4)),(R5,RJQ(3)),(R7,RJQ(5)),(JQ(15),B),(JQ(16),C)
31400		1 ,(J8,JQ(6)),(J10,JQ(8)),(R3,RJQ(1)),(J5,JQ(3)),(RJY,JQ(19))
31500		1 ,(J7,JQ(5)),(J6,JQ(4)),(R9,RJQ(7))
31600		DATA RS/10.0/,RBX/1.0/
31700		RB8=R8
31800		J3X=J3
31900	C P7=0=BDR40; =1=BDI40; =2=PRIM.
32000		CALL NOZERO(R6)
32100		R5=R6
32200	C  UPPER CASE - BDR40
32300		R6=48000000.0+(R7+50.)*10000.
32400		R7=99999999.0
32500	C  BLANKS
32600		R8=R7
32700		IF(RNUM.NE.9999.)GO TO 2
32800	C  NEXT FOR 'C'OMMON TIME
32900		RNUM=12.
33000	C  MAKES A 'C'
33100		R4=R4-2.2
33200	C  .2 FOR BAD POS. OF LETTERS
33300		GO TO 4
33400	
33500	2	ONE=0 
33600		RNUM=IFIX(RNUM)
33700	C  SO MISTAKES (i.e. 2.2) WON'T BREAK THE PROG.
33800		IF(RNUM.EQ.1.)ONE=3.
33900		IF(RNUM.GT.9.)GO TO 3
34000	C  JUMP FOR 2 OR 3 DIGIT NUMBER
34100	4	R6=R6+RNUM*100.+47.
34200	C  PUTS BLANK ON END (.47)
34300		GO TO 1
34400	
34500	3	RJY=10.
34600		IF(RNUM.GE.100.)RJY=100.
34700		B=IFIX(RNUM/RJY)
34800		C=AMOD(RNUM,RJY)
34900		IF(RNUM.LT.100)GO TO 7
35000		D=IFIX(C/10.)
35100		C=AMOD(C,10.)
35200		IF(C.EQ.1.)ONE=ONE+3.
35300		R7=C*1000000.+999999.0
35400		C=D
35500	7	R6=R6+B*100.+C
35600		IF(B.EQ.1.)ONE=ONE+3.
35700		IF(C.EQ.1.)ONE=ONE+3.
35800		B=R5
35900		IF(RNUM.GE.100.)B=B*2
36000		J3=J3-RS*RSTJ2*B
36100	C  FOR 2 DIGIT NUMBER
36200	CCC	IF(RNUM.GE.20.)GO TO 6
36300	CCC	IF(JA.EQ.18)GO TO 6
36400	CCC	RJY=5.6
36500	CCC	IF(RNUM.GT.11.)RJY=3.
36600	C  ADJUSTS FOR 11, ETC.
36700	CCC	J2=J2+RJY*R5*RSTJ2
36800	CC6	J3=J2
36900	1	J3=J3+ONE*R5*RSTJ2
37000	C CENTERS THE NUMBER '1'
37100		CALL ALPHA
37200		J3=J3X
37300		IF(RB8.EQ.0)RETURN
37400	C NEXT FOR CIRCLES AND BOXES AROUND NUMBERS.
37500		R3=J3-R5
37600		IF(J10.EQ.0)J10=1
37700	C  USE J10 FOR EVEN THICKER BOX AND CIRC.
37800		IF(RNUM.GT.9)R3=R3+R5*RBX
37900	C  TO SET CENTER
38000		IF(RB8.EQ.2)GO TO 5
38100		R4=R4+R5+.1+.05/R5
38200	C  END OF ABOVE IS FOR SMALL CIRCLES.
38300		B=4.5
38400		IF(RNUM.GE.100.)B=5.5
38500		R5=R5*B
38600		JA=12
38700		J6=0
38800		J7=0
38900		J8=J10
39000		CALL CENTX
39100		CALL SLUR
39200		RETURN
39300	
39400	5	JA=4
39500		B=6
39600		R9=0
39700		IF(RNUM.LT.100.)GO TO 8
39800		B=9.
39900		R9=R5*6.
40000	C  MAKES RECTANGLE IF ≥100
40100	8	R4=R4+R5*.7+.1
40200		R8=R5*B
40300		J5=50
40400		CALL ITMSUB
40500	C  RETURNS ORIG. HORIZ. POS.
40600		END
40700	C  MAKES ONLY 1 TO 3 DIGIT NUMS NOW.  EXPAND LATER.
40800	
40900	CC	FUNCTION IABS(N)
41000	C  BECAUSE IABS IN LIB40 HAS A BUG.
41100	CC	IABS=N
41200	CC	IF(N)IABS=-N
41300	CC	END
41400	
41500	CF	SUBROUTINE DRWNT(RMINI)
41600	CF	COMMON /STF/RSTFAC(-3/4),RSTJ2
41700	CF	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
41800	CF	EQUIVALENCE (JE,JQ(3)),(RJD,RJQ(2)),(R6,RJQ(4)),
41900	CF	1 (JG,JQ(5)),(R7,RJQ(5)),(RJE,RJQ(3)),(RJZ,RJQ(20))
42000	CF	1 ,(JI,JQ(7)),(R9,RJQ(7)),(JH,JQ(6))
42100	CF	RJX=CENTR
42200	CF	JH=0
42300	C  JH=0 SO IT WILL FILL. (P8 IN 'CLEFS')
42400	CC	CENTR=CENTR-21.*RSTJ2
42500	CF	RA=R6
42600	CF	R6=.5*RMINI/RSTJ2
42700	CF	R7=R6
42800	CF	RJD=RJZ-3
42900	CCXX	IF(RSTJ2.NE.RMINI)RJD=RJZ+.43*(RJZ-3.)-.3
43000	C  ADJUSTS POSITION FOR MINI ACCIDENTALS (..??!!)
43100	CF	JI=0
43200	CF	CALL CLEFS
43300	CF	JI=R9
43400	C  ↑↑↑↑↑↑ NEEDED??
43500	C  FIX THIS???? ↑↑↑↑↑
43600	C  FOR WHITE NOTES AND ACCIS ON PLOTTER.
43700	CF	CENTR=RJX
43800	CF	R6=RA
43900	CF	R7=JG
44000	CF	JE=RJE
44100	CF	END
44200	
44300	CC	FUNCTION RHORZ(R)
44400	CC	RHORZ=R*5.96-596.
44500	CC	END
44600	
44700	CF	SUBROUTINE RDRAW(I,S,XY,X,R3,CENTR,RMINI)
44800	C   TO X,Y INTO ONE WORD
44900	CF	DIMENSION XY(1)
45000	CF	DO 2 K=I,IFIX(S)
45100	CF	L=2
45200	CF	Y=XY(K)
45300	CF	IF(Y.LT.1000.)GO TO 3
45400	CF	L=3
45500	CF	Y=Y-1000.
45600	C   >1000 = INVIS. LINE
45700	CF3	M=Y
45800	CF	Y=(Y-M)*1000.
45900	CF	IF(Y.GT.100.)Y=100-Y
46000	C   Y NUMBERS .GT.100 ARE NEG.
46100	CF	B=Y*X+CENTR
46200	CF	IF(M.GT.60)M=100-M
46300	CF	A=M*RMINI+R3
46400	CF2	CALL LINES(A,B,L)
46500	CF	END
46600		
46700	CC	FUNCTION EEXP(X,Y)
46800	CC	EEXP=X**Y
46900	CC	END